Shareware Super Platinum 8

home *** CD-ROM | disk | FTP | other *** search

/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / PROGTOOL / LIB211.ZIP;1 / PROC.PRG < prev next >

Wrap

Text File | 1993-12-15 | 103.7 KB | 2,620 lines

*-- PROGRAM.....: PROC.PRG *----------------------------------------------------------------------- *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030) *-- Date........: 11/22/1993 *-- Version.....: See WHATS.NEW and README.TXT files (both *-- ASCII), both files uploaded with this file in one *-- zipped file. *-- Notes.......: This procedure file is part of the new and improved *-- set of files, re-designed for dBASE IV, 2.0. The *-- complete set is contained in the file: LIB211.ZIP. *-- Please read README.TXT for all instructions. *======================================================================= *======================================================================= * MESSAGE/SCREEN PROCESSING ROUTINES -- includes message boxes, * shadowing, and centering of text ... Anything not here is in the * library files SCREEN.PRG or DIALOGS.PRG *======================================================================= PROCEDURE PrintErr *----------------------------------------------------------------------- *-- Programmer..: Ken Mayer (CIS: 71333,1030) *-- Date........: 05/24/1991 *-- Notes.......: Used to display a printer error for STAND-ALONE *-- systems. (The dBASE function PRINTSTATUS() doesn't *-- work well on a Network with Print Spoolers ...) *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 05/24/1991 -- Original *-- Calls.......: SHADOW Procedure in PROC.PRG *-- CENTER Procedure in PROC.PRG *-- Called by...: Any *-- Usage.......: do printerr *-- Example.....: do setprint && if it hasn't been done *-- if .not. printstatus() *-- DO PRINTERR *-- endif *-- * or *-- do while .not. printstatus() && my preference ... *-- DO PRINTERR *-- enddo *-- Returns.....: None *-- Parameters..: None *----------------------------------------------------------------------- private cColor, cDummy, cCursor if iscolor() && if we're using a color monitor, use yellow on red m->cColor = "RG+/R,RG+/R,RG+/R" else && otherwise, use black on white m->cColor = "N/W,N/W,N/W" endif activate screen define window wPErr from 7,15 to 16,57 double color &cColor. save screen to sPErr && store current screen do shadow with 7,15,16,57 && shadow box! activate window wPErr && here we go .. m->cCursor=set("CURSOR") && save cursor setting set cursor off && turn cursor off && display message do center with 0,40,"",chr(7) + "*** PRINTER ERROR ***" do center with 2,40,""," The printer is not ready. Please check:" do center with 3,40,"","1) that the printer is ON, " do center with 4,40,"","2) that the printer is ONLINE, and" do center with 5,40,"","3) that the printer has paper. " do center with 7,40,"","Press any key to continue . . ." m->cDummy=inkey(0) && wait for user to press a key ... set cursor &cCursor. && set cursor to original setting ... *-- cleanup release window wPErr restore screen from sPErr release screen sPErr RETURN *-- EoP: PrintErr PROCEDURE Open_Screen *----------------------------------------------------------------------- *-- Programmer..: Rick Price (HAMMETT) *-- Date........: 05/24/1991 *-- Notes.......: Used to give a texture to the background of the screen *-- I got this from Rick when he uploaded it as part of *-- his original entry to a Color Contest on the ATBBS. It *-- is kinda nice to have that texture on the screen, *-- keeps it from being monotonous. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 05/24/1991 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do open_screen *-- Example.....: do open_screen *-- Returns.....: None *-- Parameters..: None *----------------------------------------------------------------------- private nRow, cBackDrp, nHoldRow clear m->nRow=0 m->cBackDrp = chr(176) && chr(176)="∞",chr(177)="±",chr(178)="≤" do while m->nRow < 3 @m->nRow,0 to m->nRow+3,79 m->cBackDrp && fill this section of the screen m->nHoldRow = m->nRow m->nRow = m->nRow + 6 @m->nRow,0 to m->nRow+3,79 m->cBackDrp m->nRow = m->nRow + 6 @m->nRow,0 to m->nRow+3,79 m->cBackDrp m->nRow = m->nRow + 6 @m->nRow,0 to m->nRow+3,79 m->cBackDrp m->nRow = m->nHoldRow + 1 enddo @24,0 to 24,79 m->cBackDrp RETURN *-- EoP: OpenScreen PROCEDURE NewBack *----------------------------------------------------------------------- *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030) *-- Date........: 06/11/1993 *-- Notes.......: Based on some ideas from Mike Irwin's presentation at *-- the 4th Annual Borland International Conference (Tips *-- and Tricks), this routine will provide a textured *-- background surface using the current colors for the *-- background, and three ascii high order characters *-- (176,177,178). It will handle different screen sizes *-- (i.e., 25 line, 43 line and 50 line). *-- WARNING: This routine assumes that the status line is *-- turned off. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/11/1993 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do NewBack *-- Example.....: do NewBack *-- Returns.....: None *-- Parameters..: None *----------------------------------------------------------------------- private cScrType, nScrHeight, cString, nTimes, nTop, nBottom, nCount m->cString = replicate("∞±≤",80) && 240 = 80 characters && times three lines m->cString2 = replicate("∞±≤",26)+"∞±" && bottom row ... m->cString3 = replicate("≤∞±",26)+"≤±" && bottom for 50 line mode *-- get the screen height -- if we have a mono monitor, it is, *-- by definition, 25 lines. m->cScrType = set("DISPLAY") if m->cScrType = "MONO" m->nScrHeight = 25 else m->nScrHeight = val(right(m->cScrType,2)) endif m->nScreen = m->nScrHeight m->nScrHeight = m->nScrHeight - 1 && start at 0, remember! *-- now, how to deal with the display? We want to do a routine where *-- we display one set at the top, one at the bottom, and back to *-- the top. This tricks the eye into thinking that it's happening *-- all at once, rather than top to bottom ... if m->nScrHeight/3 = int(m->nScrHeight/3) m->nTimes = m->nScrHeight/3 else m->nScrHeight = m->nScrHeight - 1 if m->nScrHeight/3 = int(m->nScrHeight/3) m->nTimes = m->nScrHeight/3 else m->nScrHeight = m->nScrHeight - 1 m->nTimes = m->nScrHeight/3 endif endif m->nTimes = m->nTimes / 2 *-- Now for a display loop ... m->nTop = 0 m->nBottom = m->nScrHeight - 3 m->nCount = 0 do while m->nCount < m->nTimes m->nCount = m->nCount + 1 @ m->nTop,0 say m->cString @m->nBottom,0 say m->cString m->nTop = m->nTop + 3 m->nBottom = m->nBottom - 3 enddo do case case m->nScreen = 25 .or. m->nScreen = 43 @m->nScreen-1,0 say m->cString2 case m->nScreen = 50 @48,0 say m->cString2 @49,0 say m->cString3 endcase RETURN *-- EoP: NewBack PROCEDURE JazClear *----------------------------------------------------------------------- *-- Programmer..: Rick Price (HAMMETT) *-- Date........: 05/24/1991 *-- Notes.......: Used to clear the screen from the middle out -- *-- could be used with OpenScreen, above. I got this *-- from Rick at the same time I got the other routine *-- above ... This requires a full screen (0,0 to *-- 23,79 ...) *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 05/24/1991 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do jazclear *-- Examples....: do jazclear *-- Returns.....: None *-- Parameters..: None *----------------------------------------------------------------------- private nWinR1, nWinR2, nWinC1, nWinC2, nStep, mnWinC1, mnWinC2, ; mnWinR1, mnWinR2, nStep, nTmpAdjR, nTmpAdjC, nAdjRow, nAdjCol private nColLeft, nColRite, nRowTop, nRowBot m->nWinR1 = 0 && row 1 m->nWinR2 = 24 && row 2 m->nWinC1 = 0 && column 1 m->nWinC2 = 79 && column 2 m->nStep = 1 && amount to increment by * set starting point m->mnWinC1 = int((m->nWinC2-m->nWinC1)/2)+m->nWinC1 m->mnWinC2 = m->mnWinC1+1 m->mnWinR1 = int((m->nWinR2-m->nWinR1)/2)+m->nWinR1 m->mnWinR2 = m->mnWinR1+1 ** Adjust step offset values: nColOff & m->nRowOff ** Vertical steps: m->nWinR1-m->nWinR1 m->nTmpAdjR = int((m->nWinR2 - m->nWinR1)/2) m->nTmpAdjC = int((m->nWinC2 - m->nWinC1)/2) nAdjRow = ; iif(m->nTmpAdjC > m->nTmpAdjR, m->nTmpAdjR/m->nTmpAdjC,1) * m->nStep nAdjCol = ; iif(m->nTmpAdjR > m->nTmpAdjC, m->nTmpAdjC/m->nTmpAdjR,1) * ; m->nStep m->nColLeft = m->nWinC1 m->nColRite = m->nWinC2 m->nRowTop = m->nWinR1 m->nRowBot = m->nWinR2 m->nWinC1 = m->mnWinC1 m->nWinC2 = m->mnWinC2 m->nWinR1 = m->mnWinR1 m->nWinR2 = m->mnWinR2 do while (m->nWinC1#m->nColLeft .or. m->nWinC2#m->nColRite .or. ; m->nWinR1 # m->nRowTop .or. m->nWinR2 # m->nRowBot) * Adjust coordinates for the clear (moving out from the middle) m->nWinR1 = ; m->nWinR1-iif(m->nRowTop<m->nWinR1-nAdjRow,nAdjRow,; m->nWinR1-m->nRowTop) m->nWinR2 = ; m->nWinR2+iif(m->nRowBot>m->nWinR2+nAdjRow,nAdjRow,; m->nRowBot-m->nWinR2) m->nWinC1 = ; m->nWinC1-iif(m->nColLeft<m->nWinC1-nAdjCol,nAdjCol,; m->nWinC1-m->nColLeft) m->nWinC2 = ; m->nWinC2+iif(m->nColRite>m->nWinC2+nAdjCol,nAdjCol,; m->nColRite-m->nWinC2) * Perform the clear @m->nWinR1,m->nWinC1 clear to m->nWinR2,m->nWinC2 @m->nWinR1,m->nWinC1 to m->nWinR2,m->nWinC2 enddo clear RETURN *-- EoP: JazClear PROCEDURE Wipe *----------------------------------------------------------------------- *-- Programmer..: Alan D. Frazier (CALLAE) *-- Date........: 01/10/1992 *-- Notes.......: Used to wipe a window from left to right. Nice effect. *-- Parameters are the coordinates of the window ... *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 01/10/1992 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do Wipe with <nULRow>,<nULCol>,<nBRRow>,<nBRCol> *-- Example.....: define window test from 5,10 to 20,70 *-- activate window test *-- *-- do stuff in window *-- do Wipe with 5,10,20,70 *-- Returns.....: None *-- Parameters..: nULRow = Upper (Left) Row *-- nULCol = (Upper) Left Column *-- nBRRow = Bottom (Right) Row *-- nBRCol = (Bottom) Right Column *----------------------------------------------------------------------- parameter nULRow,nULCol,nBRRow,nBRCol private nULRow,nULCol,nBRRow,nBRCol,nCurLeft m->nCurLeft = 0 && always start at column 0 within the window m->nBRRow = m->nBRRow - m->nULRow - 2 m->nBRCol = m->nBRCol - m->nULCol - 2 do while m->nCurLeft+2 < m->nBRCol @ 0,m->nCurLeft clear to m->nBRRow,m->nCurLeft + 2 m->nCurLeft = m->nCurLeft + 2 enddo @ 0,m->nBRCol-2 CLEAR TO m->nBRRow,m->nBRCol - 1 RETURN *-- EoP: Wipe PROCEDURE Center *----------------------------------------------------------------------- *-- Programmer..: Miriam Liskin *-- Date........: 05/24/1991 *-- Notes.......: Centers text on the screen with @says *-- Written for.: dBASE IV, 1.1 *-- Rev. History: This and all other procedures/functions listed in this *-- file attributed to Miriam Liskin came from "Liskin's *-- Programming dBASE IV Book". Highly Recommended. *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do center with <nLine>,<nWidth>,"<cColor>","<cText>" *-- Example.....: do center with 5,65,"RG+/GB",; *-- "WARNING! This will blow up!" *-- Note that the color field may be blank: "" *-- Returns.....: None *-- Parameters..: nLine = Line or Row for @/Say *-- nWidth = Width of screen *-- cColor = Colors to be used ("Forg/Back") *-- (may be nul "", in order to use the default *-- colors of window/screen) *-- cText = Message to center on screen *----------------------------------------------------------------------- parameters nLine,nWidth,cColor,cText private nCol m->nCol = (m->nWidth - len(m->cText)) /2 @m->nLine,m->nCol say m->cText color &cColor. RETURN *-- EoP: Center PROCEDURE ProgBar *----------------------------------------------------------------------- *-- Programmer..: Joey D. Carroll (JOEY) *-- Date........: 10/26/1992 *-- Notes.......: A visual indicator of program activity, i.e. shows *-- user program didn't die during long processes which *-- do not normally show 'on screen'. Serves same purpose *-- as MONITOR, but is more graphic. *-- For best appearance, set cursor 'off' from calling *-- program, outside of the loop which calls PROGBAR. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/28/1992 -- Original *-- 10/26/1992 - Fixed bug(feature) so that cMessage *-- prints the color requested by cWindCol. Protected *-- existing active Window. (Joey Carroll) *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do PROGBAR with <nQuan>,<cWindCol>,<cFillCol1>,; *-- <cFillCol2>,<cMessage>,<nWindWidth> *-- Example.....: *-- determine what process will be monitored and what *-- *-- the final value will be, e.g. *-- *-- nReccount = reccount() *-- use <anyfile> *-- nReccount = reccount() *-- set cursor off *-- scan *-- do progbar with nReccount,",,w+/n","w+/r","w+/g", ; *-- "Processing records. Be patient.",40 *-- *-- do some needed process here *-- endscan *-- *-- cleanup *-- Returns.....: None *-- Parameters..: nQuan = maximum number of iterations *-- cWindCol = the window colors *-- cFillCol1 = color of ruler before process *-- cFillCol2 = color of ruler after process *-- cMessage = message displayed to user, may be "". *-- nWindWid = (optional) desired width of ruler window. *-- If not specified, width of screen. If *-- specified, will not be less than length of *-- message. *----------------------------------------------------------------------- parameters nQuan,cWindCol,cFillCol1,cFillCol2,cMessage,nWinWidth private Message,x, nParms *-- Was message passed as a parameter? m->lMessage = iif(.not. isblank(m->cMessage), .t., .f.) *-- find out # of parameters passed ... if val(right(version(),3)) > 1.1 m->nParms = pcount() else m->nParms = 6 endif *-- all the way if width not passed m->nWinWidth = iif(m->nParms = 6,m->nWinWidth,78) *-- width param > 78 not allowed m->nWinWidth = min(m->nWinWidth,78) *-- window width can't be narrower than messsage, so.... m->nWinWidth = iif(m->lMessage,max(m->nWinWidth,len(m->cMessage) +; 2),m->nWinWidth) *-- skip this section if we've been here before *-- this procedure called from inside a loop *-- following section ignored except on first iteration thru loop if type("m->nTimes") = "U" && check to see if we been here before save screen to sProgBar *-- make these available on all iterations public m->nFactor,m->nTimes,m->wPrevWind *-- was a window active? m->wPrevWind = window() *-- don't overwrite status m->nProgLine = iif(set("status") = "ON",20,22) *-- determine how wide the window needs to be define window wProgBar from ; m->nProgLine - iif(m->lMessage, 2, 1),(80 - ; (m->nWinWidth + 2)); / 2 to m->nProgLine + 1,(80 + (m->nWinWidth + 2)) / 2 - 1 ; double color &cWindCol. activate window wProgBar @ 0,0 say replicate(".",m->nWinWidth - 1) && the ruler @ 0,0 say "0%" && and some gradation %'s @ 0,m->nWinWidth / 4 - 2 say "25%" @ 0,m->nWinWidth / 2 - 2 say "50%" @ 0,3*(m->nWinWidth / 4) - 2 say "75%" @ 0,m->nWinWidth - 4 say "100%" *-- color of ruler before process @ 0,0 fill to 0,m->nWinWidth - 1 color &cFillCol1. if m->lMessage @ 1,(m->nWinWidth - (len(m->cMessage))) / 2 say m->cMessage endif *-- e.g. how many records per bar part(cols) m->nFactor = m->nQuan/m->nWinWidth m->nTimes = 0 && times thru loop endif && type("nTimes") = "U" *-- this section will be processed as many times as required by nQuan m->nTimes = m->nTimes + 1 @ 0,0 fill to 0,int(m->nTimes / m->nFactor) ; - iif(int(m->nTimes / m->nFactor) - 1 >= 0, 1, 0) ; color &cFillCol2. && color of ruler as processing occurs if m->nTimes = m->nQuan && we're done x = inkey(.5) && leave on screen just a liitle while after && completion *-- cleanup your mess release window wProgBar restore screen from sProgBar release screen sProgBar *-- Reactivate window if it existed if .not. isblank(m->wPrevWind) activate window &wPrevWind. endif release m->nFactor,m->nTimes,m->lMessage,x,m->wPrevWind endif && nTimes = nQuan RETURN *-- EoP: ProgBar PROCEDURE Shadow *----------------------------------------------------------------------- *-- Programmer..: Ashton-Tate *-- Date........: 06/02/1993 *-- Notes.......: Creates a shadow for a window (taken from the dBASE IV *-- picklist functions) *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 05/23/1991 - original procedure. *-- 12/14/1991 - Modified by Jim Magnant (TXAGGIE) - to *-- check for columns exceeding 79, and temporarily *-- change last col. value (so routine doesn't "blow *-- up"). *-- 01/27/1992 -- Modifiedy by Ken Mayer to check for *-- bottom of screen, based on what Jim did above. No *-- further than 23. *-- 06/02/1993 -- Modified to handle screens larger than *-- 24 lines. (KJM) *-- Calls.......: None *-- Called by...: Too many to list ... *-- Usage.......: do shadow with <nULRow>,<nULCol>,<nBRRow>,<nBRCol> *-- Example.....: save screen to sMain *-- activate screen *-- define window wError from 5,15 to 15,65 double color; *-- rg+/r,rg+/r,rg+/r *-- do shadow with 5,15,15,65 *-- activate window WError *-- && perform actions in window *-- release window WError *-- restore screen from sMain *-- release screen sMain *-- Returns.....: None *-- Parameters..: nULRow = Upper Left Row position *-- nULCol = Upper Left Column position (x,y) *-- nBRRow = Bottom Right Row position *-- nBRCol = Bottom Right Column position (x2,y2) *----------------------------------------------------------------------- parameters nULRow,nULCol,nBRRow,nBRCOL private nTempRow,nTempCol,nIncRow,nIncCol,cScreen,nScreen *-- if screen is larger than 24 lines (EGA43, EGA50 ...) m->cScreen = set("DISPLAY") if m->cScreen = "MONO" m->nScreen = 23 else m->nScreen = val(right(m->cScreen,2))-2 endif m->nTempRow = iif(m->nBRRow+1>m->nScreen,m->nScreen,m->nBRRow+1) m->nTempCol = iif(m->nBRCol+2>79,79,m->nBRCol+2) m->nIncRow = 1 m->nIncCol = (m->nBRCol-m->nULCol) / (m->nBRRow-m->nULRow) do while m->nTempRow <> m->nULRow .or. m->nTempCol <> m->nULCol+2 m->nRightCol = m->nBRCol m->nBRCol = iif(m->nBRCol + 2 > 79,77,m->nBRCol) m->nBotRow = m->nBRRow m->nBRRow = iif(m->nBRRow + 1 > m->nScreen,m->nScreen-1,m->nBRRow) @ m->nTempRow,m->nTempCol fill to m->nBRRow+1,m->nBRCol+2 ; color n+/n m->nBRCol = m->nRightCol m->nBRRow = m->nBotRow m->nTempRow = iif(m->nTempRow<>m->nULRow,m->nTempRow -m->nIncRow,; m->nTempRow) m->nTempCol = iif(m->nTempCol<>m->nULCol+2,m->nTempCol - ; m->nIncCol,m->nTempCol) m->nTempCol = iif(m->nTempCol<m->nULCol+2,m->nULCol+2,m->nTempCol) enddo RETURN *-- EoP: Shadow FUNCTION VPick *----------------------------------------------------------------------- *-- Programmer..: Keith G. Chuvala (CIS: 71600,2033) *-- Date........: 06/08/1992 *-- Notes.......: Keith wanted a multiple choice picklist routine for *-- use with a mouse (or other) ... he got the idea for *-- the AT-USER system which he was Beta Testing. Here *-- 'tis ... This creates a quick pick-list for *-- multiple-choice, single-character input. The first *-- letter of the selected bar is returned. If <Esc> is *-- pressed, a null string is returned. *-- NOTE: If using this with dBASE IV, 1.1, you must *-- supply a parameter for each option below. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/02/1992 -- Keith first gave this to Ken Mayer to *-- use with the BORUSER system. *-- 06/08/1992 -- Modified to allow passing of a color *-- memvar, and then to use explicit color definitions *-- based on it. *-- 11/09/1992 - Joey Carrol modified to allow use of *-- function when another window is active, and to *-- insure color integrity *-- Calls.......: COLORBRK() Function in PROC.PRG *-- RECOLOR Procedure in PROC.PRG *-- Called by...: Any *-- Usage.......: ?VPick(<m->nRow>,<nCol>,"<cOptions>","<cTitle>",; *-- "<cMessage>",<lShadow>,<cColor>) *-- Example.....: cHow = VPick(12,15,"~BorBBS ID~Lastname",; *-- "How do you want the data sorted?",; *-- "Choose one","rg+/gb,w+/b,rg+/gb") *-- Returns.....: First letter of bar selected, or null if <Esc>. *-- Parameters..: nRow = is a numeric value for the top row of the *-- popup. *-- nCol = is a numeric value for the left column. *-- cOptions = is a string of options with each preceded *-- by '~', e.g. "~Screen~Printer~Text File~ *-- Return to Menu" *-- cTitle = is an optional title, used for the popup *-- heading *-- cMessage = is an optional message string for when *-- the popup is activated on the screen. *-- lShadow = is a logical value indicating whether or *-- not a shadow is to be placed under the *-- e.g. how many records per bar part(cols) *-- popup. *-- cColor = Colors to be used. Should have three parts *-- -- <normal/unselected text>,<highlighted *-- text>,<border>, using the format *-- "Foreground/Background" *-- for each. So examine the example above. *----------------------------------------------------------------------- parameters nRow,nCol,cOptions,cTitle,cMessage,lShadow,cColor private nRow,nCol,cOptions,cTitle,cMessage,lShadow,cTempCol,cCurColor *-- get number of parameters, and a few setup steps ... if val(right(version(),3)) > 1.1 && if version of dBASE && (RunTime) > 1.1 m->nParameters = pcount() else m->nParameters = 7 endif m->nCount = 0 m->cReturn = "" m->cOptions = trim(m->cOptions) m->cDispMesg = "" *-- if number of parameters greater/equal to 5, we may have a message *-- at the bottom of the screen ... if m->nParameters >= 5 if len(m->cMessage) > 0 m->cDispMesg = "MESSAGE "+"'"+m->cMessage+"'" endif endif *-- make it work even if a window is active. m->wPrevWind = window() activate screen *-- define the popup define popup pPickList from m->nRow,m->nCol &cDispMesg. m->nMessage1 = 0 *-- if we have 4 or more parameters, one of them is the title ... *-- this requires that the first two bars of the menu be skipped ... if m->nParameters >= 4 if len(m->cTitle) > 0 m->cTitle = " "+m->cTitle+" " m->nMessage1 = len(m->cTitle) m->nCount = 2 endif endif *-- save current colors m->cCurColor = set("ATTRIBUTES") *-- set new ones m->cTempCol = colorbrk(m->cColor,1) set color of normal to &cTempCol. set color of message to &cTempCol. m->cTempCol = colorbrk(m->cColor,2) set color of highlight to &cTempCol. m->cTempCol = colorbrk(m->cColor,3) set color of box to &cTempCol. *-- now we start parsing the options for the menu. These must have *-- a tilde between each, so we look for the first one, and then *-- look again to see if there's another after that. m->nPos1 = at("~",m->cOptions) && Look for first tilde do while (len(m->cOptions) > 0) .and. (m->nPos1 > 0) && parsing loop if m->nPos1 > 0 m->cSub = substr(m->cOptions,m->nPos1+1,len(m->cOptions)-; m->nPos1) m->nPos2 = at("~",m->cSub) if m->nPos2 = 0 m->nPos2 = len(m->cSub) else m->nPos2 = m->nPos2 - 1 endif m->cOptString = " "+left(m->cSub,m->nPos2)+" " if len(m->cOptString) > m->nMessage1 m->nMessage1 = len(m->cOptString) endif *-- define the actual 'bar' of the menu/picklist ... m->nCount = m->nCount + 1 define bar m->nCount of pPickList prompt m->cOptString m->cOptions = m->cSub endif m->nPos1 = at("~",m->cOptions) enddo && end of parsing loop *-- now we deal with defining the actual picklist ... if m->nCount > 0 && if we have something to put in the && list ... if m->nParameters >= 4 && if we have a title for the top ... if len(m->cTitle) > 0 if len(m->cTitle) < m->nMessage1 m->cTitle = trim(ltrim(m->cTitle)) m->cTitle = space((m->nMessage1-len(m->cTitle)) / 2) +; m->cTitle endif define bar 1 of pPickList prompt m->cTitle skip define bar 2 of pPickList prompt replicate(chr(196),; m->nMessage1) skip endif endif *-- define what to do when a choice is made ... on selection popup pPickList deactivate popup *-- if we have a shadow, let's save screen and do the shadow *-- before popping up the picklist if m->nParameters => 6 if m->lShadow save screen to sPickScr @ m->nRow+1,m->nCol+2 fill to m->nRow+m->nCount+2,m->nCol+; m->nMessage1+3 color w/n endif else m->lShadow = .f. endif *-- there we are ... activate popup pPickList *-- cleanup if m->lShadow restore screen from sPickScr release screen sPickScr endif *-- deal with what to 'return' ... if lastkey() = 27 m->cReturn = "" else m->cReturn = substr(prompt(),2,1) endif endif && nCount > 0 *-- we're done with it ... return it back to the electronic byte *-- storage bins ... release popup pPickList do ReColor with m->cCurColor *-- was there an existing window? if .not. isblank(m->wPrevWind) activate window &wPrevWind. endif RETURN m->cReturn *-- EoF: VPick() FUNCTION HPick *----------------------------------------------------------------------- *-- Programmer..: Keith G. Chuvala (CIS: 71600,2033) *-- Date........: 11/09/1992 *-- Notes.......: Creates a horizontal pick list for multiple-choice *-- single-character input. The first letter of the *-- selected pad is returned. If <ESC> is pressed, a *-- null string is returned. *-- Written for.: dBASE IV, 1.1, 1.5 *-- Rev. History: 06/12/1992 -- Original *-- 11/09/1992 - Modified to allow use when another window *-- is active, and to ensure color integrity (Joey *-- Carroll). *-- Calls.......: COLORBRK() Function in PROC.PRG *-- RECOLOR Procedure in PROC.PRG *-- Called by...: Any *-- Usage.......: HPICK(<nRow>,<nCol>,"<cOptions>","<cTitle>",; *-- "<cMessage>",<lShadow>,"<cColor>") *-- Example.....: x=HPick(8,5,"~Screen~Printer~Text File~Return - Menu",; *-- "Output Options","Select one, or <Esc> to exit",; *-- .t.,"rg+/gb,w+/b,rg+/gb") *-- Returns.....: First letter of selected 'pad', or null if <Esc>. *-- Parameters..: nRow = a numeric value for the top row of the *-- popup. *-- nCol = a numeric value for the left column of the *-- popup. *-- cOptions = a string of options with each preceded by *-- '~', e.g. "~Screen~Printer~Text File~; *-- Return to Menu" *-- cTitle = an optional title, used for the popup *-- heading *-- cMessage = an optional message string for when the *-- popup is activated on the screen. *-- lShadow = a logical value indicating whether or not *-- a shadow is to be placed under the popup. *-- cColor = Colors passed to function in format: *-- <Text/Unselected Pad>,<Selected Pad>,; *-- <Border> *----------------------------------------------------------------------- parameters nRow,nCol,cOptions,cTitle,cMessage,lShadow, cColor private cPickColor,cTempCol *-- get number of parameters, and a few setup steps *-- if version 1.5 or later, # of parms is optional ... if val(right(version(),3)) > 1.1 && if version of dBASE > 1.1 m->nParameters = pcount() else m->nParameters = 7 endif m->nCount = 0 m->nStartCol = m->nCol m->cOptions = trim(m->cOptions) m->cDispMess = "" *-- make it work even if a window is active m->wPrevWind = window() activate screen *-- save current colors, set up colors for this routine m->cPickColor = set("ATTRIBUTES") m->cTempCol = colorbrk(m->cColor,1) set color of normal to &cTempCol. set color of message to &cTempCol. m->cTempCol = colorbrk(m->cColor,2) set color of highlight to &cTempCol. m->cTempCol = colorbrk(m->cColor,3) set color of box to &cTempCol. m->cPadName = "p" *-- if # of parameters => 5, we may have a message at the bottom of *-- the screen ... if m->nParameters >= 5 if len(m->cMessage) > 0 m->cDispMess = "MESSAGE "+"'"+m->cMessage+"'" endif endif *-- start defining the menu ... define menu mHPick &cDispMess. if m->nParameters >= 4 if len(m->cTitle) > 0 m->cTitle = " "+m->cTitle+" " endif endif *-- here, we have to parse the cOptions field for the tilde "~" *-- character, which is how we know we have a new pad ... m->nPos1 = at("~",m->cOptions) && position of first tilde do while (len(m->cOptions) > 0) .and. (m->nPos1 > 0) && parsing loop if m->nPos1 = 0 .and. (len(m->cOptions) > 0) m->nPos1 = len(m->cOptions) endif if m->nPos1 > 0 m->cSubString = substr(m->cOptions,m->nPos1+1,; len(m->cOptions)-m->nPos1) m->nPos2 = at("~",m->cSubString) if m->nPos2 = 0 m->nPos2 = len(m->cSubString) else m->nPos2 = m->nPos2 - 1 endif m->cOptString = " "+left(m->cSubString,m->nPos2)+" " m->nCount = m->nCount + 1 m->cPadName = "p"+ltrim(trim(str(m->nCount))) define pad &cPadName. of mHPick prompt m->cOptString at; m->nRow,m->nCol m->nCol = m->nCol + len(m->cOptString) on selection pad &cPadName. of mHPick deactivate menu m->cOptions = m->cSubString endif m->nPos1 = at("~",m->cOptions) enddo *-- done figure that out. On to more stuff ... save screen to sPickList *-- do we have a shadow? if m->lShadow @ m->nRow,m->nStartCol+2 fill to m->nRow+2,m->nCol+2 endif *-- draw border @ m->nRow-1,m->nStartCol-1 to m->nRow+1,m->nCol *-- display 'title' if len(m->cTitle) > 0 @ m->nRow-1,m->nStartCol+1 say m->cTitle endif *-- start 'er up ... activate menu mHPick *-- that's it ... return screen to it's original *-- state ... restore screen from sPickList release screen sPickList *-- deal with user keystroke/selection ... if lastkey() = 27 m->cReturn = "" else m->cReturn = substr(prompt(),2,1) endif *-- cleanup. release menu mHPick do ReColor with m->cPickColor && reset colors *-- was there an existing window? if .not. isblank(m->wPrevWind) activate window &wPrevWind. endif RETURN m->cReturn *-- EoF: HPick() *----------------------------------------------------------------------- *-- The Following Routines are in DIALOGS.PRG under slightly different *-- names: *-- Here DIALOGS.PRG *-- SCRNHEAD SCRNHEAD3 *-- SURROUND SURROUND3 *-- ALERT ALERT5 *-- ERRORMSG ERRORMSG3 *-- YESNO YESNO6 *-- BORD3D BORD3D5 *-- All of these have been seriously modified -- if you have been using *-- earlier versions of these routines, please read the documentation *-- below carefully! *----------------------------------------------------------------------- FUNCTION ScrnHead *----------------------------------------------------------------------- *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030) *-- Date........: 06/09/1993 *-- Notes.......: Displays a heading on the screen in a box at the top *-- of the screen. This may be in one of four types of *-- borders, giving a three-d appearance. *-- NOTE: This routine is based on the work of Miriam *-- Liskin, and my own modifications over the years. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/09/1993 -- Original *-- Calls.......: SHADOW Procedure in PROC.PRG *-- BORD3D Procedure in PROC.PRG *-- Called by...: Any *-- Usage.......: scrnhead("<cColor>","<cText>"[,<nStyle>]) *-- Examples....: cDummy = ScrnHead("rg+/gb","Print Financial Report",1) *-- Returns.....: nul/"" *-- Parameters..: cColor = Colors to display box/text in *-- Default to grey *-- cText = text to be displayed. *-- nStyle = Type of 3-d Border (passed directly to *-- procedure) *-- 1 = double - raised (Default) *-- 2 = double - recessed *-- 3 = single - raised *-- 4 = single - recessed *----------------------------------------------------------------------- parameters cColor,cText, nStyle private nTextStart,cText2 *-- if style parameter not passed, use default if pCount() < 3 .or. (m->nStyle < 1 .or. m->nStyle > 4) m->nStyle = 1 endif *-- colors if isblank(m->cColor) m->cColor = "n/w" endif m->cText2 = " "+trim(m->cText)+" " && ad spaces to left and right m->nTextStart = (81-len(trim(m->cText2)))/2 && centered text activate screen m->nTop = iif(m->nStyle < 3,0,1) m->nLeft = m->nTextStart - iif(m->nStyle<3,3,2) && back up 3 (or 2) m->nBottom = iif(m->nStyle < 3,4,3) && bottom row m->nRight = (81-m->nTextStart) + iif(m->nStyle<3,3,2) *-- draw shadow do shadow with m->nTop,m->nLeft,m->nBottom,m->nRight *-- fill in box @m->nTop,m->nLeft fill to m->nBottom,m->nRight color &cColor. *-- place border on top of it all do bord3d with m->nTop,m->nLeft,m->nBottom,m->nRight,m->cColor,; m->nStyle *-- finally, let's display the text ... @2, m->nTextStart say m->cText2 color &cColor. RETURN "" *-- EoF: ScrnHead() FUNCTION Surround *----------------------------------------------------------------------- *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030) *-- Date........: 06/28/1993 *-- Notes.......: Displays a message surrounded by a box anywhere on *-- the screen -- this version centers automatically on *-- the screen and gives a 3-D border ... *-- This is based on the original routine by Miriam Liskin *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/09/1993 -- Original *-- 06/28/1993 -- Fixed minor problem -- if displaying *-- over a textured background, the borders *-- can look a bit odd. Added a CLEAR ... *-- Calls.......: SHADOW Procedure in PROC.PRG *-- Bord3D Procedure in PROC.PRG *-- Called by...: Any *-- Usage.......: Surround(<nLine>,"<cColor>","<cText>"[,<nStyle>]) *-- Example.....: cDummy = Surround(5,12,"RG+/GB",; *-- "Processing ... Do not Touch!",1) *-- Returns.....: Nul/"" *-- Parameters..: nLine = Line to display "surrounded" message at *-- if nLine = 0, we will center on the screen *-- vertically, as well as horizontally. *-- cColor = Color variable/colors (Default to grey) *-- cText = Text to be displayed inside box *-- nStyle = Style of border 1 = Double - Raised(Default) *-- 2 = Double - Recessed *-- 3 = Single - Raised *-- 4 = Double - Recessed *-- NOTE: This is OPTIONAL *----------------------------------------------------------------------- parameters nLine,cColor,cText,nStyle private nStyle, cColor, cText2, nTextStart, nTop, nLeft, nBottom,; nRight, nLine *-- deal with defaults if pCount() < 4 .or. (m->nStyle < 1 .or. m->nStyle > 4) m->nStyle = 1 endif if isblank(m->cColor) m->cColor = "n/w" endif *-- deal with nLine being equal to 0 when user passes this (this will *-- cause the routine to center on the screen ... no matter how the *-- screen is set). if m->nLine = 0 m->cScreen = set("DISPLAY") if m->cScreen = "MONO" m->nScreen = 24 else m->nScreen = val(right(m->cScreen,2)) - 1 && EGA25 = 0 to 24 endif m->nLine = int(m->nScreen/2) && halfway ... endif m->cText2 = " "+trim(m->cText)+" " && add spaces to left and right m->nTextStart = (81-len(trim(m->cText2)))/2 && centered text activate screen m->nTop = m->nLine - iif(m->nStyle < 3,2,1) && up 2 or 1 ... m->nLeft = m->nTextStart - iif(m->nStyle < 3,3,2) && back up 3 m->nBottom = m->nLine + iif(m->nStyle < 3,2,1) && bottom row m->nRight = (81-m->nTextStart) + iif(m->nStyle < 3,3,2) && right *-- draw shadow do shadow with m->nTop,m->nLeft,m->nBottom,m->nRight *-- fill in box @m->nTop,m->nLeft clear to m->nBottom,m->nRight @m->nTop,m->nLeft fill to m->nBottom,m->nRight color &cColor. *-- place border on top of it do Bord3D with m->nTop,m->nLeft,m->nBottom,m->nRight,m->cColor,; m->nStyle *-- finally, let's display the text ... @m->nLine, m->nTextStart say m->cText2 color &cColor. RETURN "" *-- EoF: Surround() FUNCTION Alert *----------------------------------------------------------------------- *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030) *-- Date........: 06/11/1993 *-- Notes.......: This is a general purpose "ALERT" dialog box. It is *-- based heavily on the original work by Adam L. Menkes *-- (Borland Technical Support), and Joey D. Carrol, as *-- well as various tinkerings I have done in previous *-- versions. This routine creates a popup on the screen *-- with a title and one line message (wrapped if needed), *-- forcing the user to notice the message. *-- The user must use the mouse on the 'OK' pad, press *-- <Esc> or press <Enter> to move on in the program that *-- called this function. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/19/1992 -- Adam L. Menkes -- Original "Alert()" *-- routine. *-- 06/11/1993 -- Kenneth J. Mayer -- complete overhaul. *-- Calls.......: SHADOW Procedure in PROC.PRG *-- JUSTIFY() Function in PROC.PRG *-- COLORBRK() Function in PROC.PRG *-- FBCLRBRK() Function in PROC.PRG *-- BORD3D Procedure in PROC.PRG *-- Called by...: Any *-- Usage.......: Alert("<cTitle>","<cMessage>","<cColor>"[,<nStyle>]) *-- Example.....: lX = Alert("Print Aborted","You pressed <ESC>",; *-- "rg+/r,w+/b,rg+/r",2) *-- Returns.....: Logical *-- Parameters..: cTitle = Title line *-- cMessage = One line message (up to 254 characters) *-- cColor = Colors: <window forg/back>,<pad> (and *-- title),<box> *-- Default is to "steel" grey *-- nStyle = OPTIONAL: 1 = double raised border(default) *-- 2 = double recessed bord *-- 3 = single raised *-- 4 = single recessed *----------------------------------------------------------------------- parameters cTitle, cMessage, cColor, nStyle private wWindow,mPad,cTempCol,cColorF,cColorB,cColorAll private nWidth,nTop,nLeft,nBottom,nRight,cTitle2,cMessage2 *-- don't jamb against walls m->cTitle2 = " " + ltrim(trim(m->cTitle)) + " " m->cMessage2 = " " + ltrim(trim(m->cMessage)) + " " wWindow = WINDOW() && save current Window save screen to sTemp && save the screen activate screen cDummykey = inkey() && clear out keyboard buffer *-- deal with defaults if pCount() < 4 .or. (m->nStyle < 1 .or. m->nStyle > 4) m->nStyle = 1 endif if pCount() < 3 && no colors? default to grey m->cColor = "n/w,w+/n,n/w" endif if isblank(m->cColor) m->cColor = "n/w,w+/n,n/w" endif *-- determine coordinates -- we're basing some of this on YESNO() *-- routines -- alert box will be only so wide ... m->nWidth = 36 + iif(m->nStyle<3,4,2) *-- height will be based on how many lines of message we have m->nHeight = int(len(m->cMessage)/m->nWidth) +; iif(mod(len(m->cMessage),m->nWidth) > 0,1,0) +; iif(m->nStyle < 3,3,1) + 6 *-- now we have height and width,let's determine where to center this *-- first, we need screen height m->cScreen = set("DISPLAY") if m->cScreen = "MONO" m->nScreen = 24 else m->nScreen = val(right(m->cScreen,2)) - 1 && (EGA25 = 0 to 24) endif *-- now to determine coordinates m->nTop = (m->nScreen - m->nHeight) / 2 m->nBottom = m->nTop + m->nHeight m->nLeft = 20 m->nRight = m->nLeft + m->nWidth *-- define window (with no border so we can place the 3-D one on it) Define window wAlert from m->nTop,m->nLeft to m->nBottom,m->nRight ; NONE color &cColor. *-- display shadow do shadow with m->nTop,m->nLeft,m->nBottom,m->nRight *-- start 'er up ... activate window wAlert *-- put 3-D Border in there m->cBordCol = colorbrk(m->cColor,1) do BORD3D with 0,0,(m->nBottom-m->nTop),m->nWidth,m->cBordCol,; m->nStyle *-- display a new type title line to look more like Windows(TM) if len(m->cTitle) < m->nWidth m->cTitle = justify(m->cTitle,35,"C") if len(m->cTitle) < 35 m->cTitle = m->cTitle + " " endif endif m->cTempCol = colorbrk(m->cColor,2) *-- Background of title bar text m->cColorF = FBClrBrk("B",m->cTempCol) *-- Foreground of 'normal' text m->cColorB = FBClrBrk("B",colorbrk(m->cColor,1)) *-- color of 'Special' line m->cColorAll = m->cColorF + "/" + m->cColorB m->nRow = iif(m->nStyle<3,2,1) m->nCol = iif(m->nStyle<3,3,2) @m->nRow, m->nCol say m->cTitle color &cTempCol. && the Title Bar @m->nRow+1,m->nCol say replicate(chr(223),35) color &cColorAll. *-- display message do WordWrap with iif(m->nStyle<3,4,3),iif(m->nStyle<3,4,3),; m->cMessage,34 *-- define/display a very small menu (one pad) define menu mAlert m->nButtonRow = m->nHeight - iif(m->nStyle<3,3,2) m->nButtonCol = m->nWidth/2 - 1 define pad pPad1 of mAlert prompt "[OK]" at m->nButtonRow,; m->nButtonCol on selection pad pPad1 of mAlert deactivate menu *-- deal with <Enter> on key label ctrl-M keyboard "{27}" *-- before starting, put a border around the button do bord3d with m->nButtonRow-1,m->nButtonCol-1,m->nButtonRow+1,; m->nButtonCol+4,m->cBordCol,3 *-- start it up activate menu mAlert *-- deal with user 'input' m->mPad = pad() deactivate window wAlert release window wAlert *-- restore environment, free up RAM by releasing things on key label ctrl-m restore screen from sTemp release screen sTemp release menu mAlert if "" # wWindow activate window &wWindow. endif RETURN .not. "" = m->mPad && not empty pad? *-- EoF: Alert() FUNCTION ErrorMsg *----------------------------------------------------------------------- *-- Programmer..: Ken Mayer (CIS: 71333,1030) *-- Date........: 06/11/1993 *-- Notes.......: Display an error message in a Window: *-- ** ERROR [#] ** *-- *-- Message (wraps in window) *-- *-- [OK] *-- *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/08/1992 -- Original *-- 03/18/1993 -- Modified to give the three-d border ... *-- 06/10/1993 -- Modified to give 4 options to border, *-- default color of grey/black/white, *-- handle single message of up to 254 *-- characters. *-- Calls.......: SHADOW Procedure in PROC.PRG *-- CENTER Procedure in PROC.PRG *-- ALLTRIM() Function in PROC.PRG *-- WORDWRAP Procedure in PROC.PRG *-- BORD3D Procedure in PROC.PRG *-- Called by...: Any *-- Usage.......: ErrorMsg(<cErr>,<cMess>[,<cColor>[,<nStyle>]]) *-- Example.....: cDummy = errormsg("3","This record already exists!",; *-- "rg+/r,rg+/r,rg+/r",2) *-- Returns.....: numeric value of keystroke user presses (cUser) *-- Parameters..: cErr = Error # (can be blank, but use "" for blank) *-- cMess = Error message -- up to 254 characters *-- cColor = Colors for text/window/border (default=grey) *-- nStyle = 1 = Double - Raised *-- 2 = Double - Recessed *-- 3 = Single - Raised *-- 4 = Single - Recessed *----------------------------------------------------------------------- parameters cErr,cMess,cColor,nStyle private cCursor,cUser,cCurColor,cTempCol *-- defaults if pCount() < 4 .or. (m->nStyle < 1 .or. m->nStyle > 4) m->nStyle = 1 endif if pCount() < 3 m->cColor = "n/w,w+/n,n/w" endif if isblank(m->cColor) m->cColor = "n/w,w+/n,n/w" endif *-- screen stuff save screen to sErr m->cWindow = window() activate screen *-- determine coordinates *-- width is a default of 36 characters, plus border ... m->nWidth = 36 + iif(m->nStyle < 3, 4, 2) && based on border style *-- height is based on lines in message m->nHeight = int(len(cMess)/m->nWidth) +; iif( mod( len(cMess), m->nWidth) > 0,1,0) +; iif(m->nStyle < 3,3,1) + 6 *-- now we have height and width, let's determine how to center this *-- puppy on the screen m->cScreen = set("DISPLAY") if m->cScreen = "MONO" m->nScreen = 24 else m->nScreen = val(right(m->cScreen,2)) - 1 endif *-- coordinates m->nTop = (m->nScreen-m->nHeight) / 2 m->nBottom = m->nTop + m->nHeight m->nLeft = 20 m->nRight = m->nLeft + m->nWidth *-- define the window define window wErr from m->nTop,m->nLeft to m->nBottom,m->nRight ; NONE color &cColor. do shadow with m->nTop,m->nLeft,m->nBottom,m->nRight activate window wErr *-- do border m->cBordCol = colorbrk(m->cColor,1) do bord3d with 0,0,(m->nBottom-m->nTop),m->nWidth,m->cBordCol,; m->nStyle m->cCursor = set("CURSOR") set cursor off *-- deal with "title" line if len(trim(m->cErr)) > 0 && if there's an error number ... m->cTitle = "** ERROR "+alltrim(m->cErr)+" **" else && otherwise, don't display errornumber m->cTitle = "** ERROR **" endif m->cTitle = justify(m->cTitle,35,"C") if len(m->cTitle) < 35 m->cTitle = m->cTitle + " " endif m->cTempCol = colorbrk(m->cColor,2) m->cColorF = fbclrbrk("B",m->cTempCol) m->cColorB = fbclrbrk("B",colorbrk(m->cColor,1)) m->cColorAll = m->cColorF+"/"+m->cColorB m->nRow = iif(m->nStyle<3,2,1) m->nCol = iif(m->nStyle<3,3,2) @m->nRow,m->nCol say m->cTitle color &cTempCol. @m->nRow+1,m->nCol say replicate(chr(223),35) color &cColorAll. *-- display message do wordwrap with iif(m->nStyle<3,4,3),iif(m->nStyle<3,4,3),cMess,34 *-- define menu ... define menu mError m->nButtonRow = m->nHeight - iif(m->nStyle<3,3,2) m->nButtonCol = m->nWidth/2 - 1 define pad pPad1 of mError prompt "[OK]" at m->nButtonRow,; m->nButtonCol on selection pad pPad1 of mError deactivate menu on key label ctrl-M keyboard "{27}" do bord3d with m->nButtonRow-1,m->nButtonCol-1,m->nButtonRow+1,; m->nButtonCol+4,m->cBordCol,3 *-- start menu activate menu mError *-- deal with user 'input' m->mPad = pad() *-- reset and cleanup set cursor &cCursor. release window wErr restore screen from sErr release screen sErr release menu mError on key label ctrl-M if "" # m->cWindow activate window &cWindow. endif RETURN .not. "" = m->mPad && empty pad? *-- EoF: ErrorMsg() FUNCTION YesNo *----------------------------------------------------------------------- *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030) *-- Date........: 06/11/1993 *-- Notes.......: This is a combination of the "best" of YESNO4() and *-- YESNO5() (I hope). The work involved is based on work *-- by Miriam Liskin, Martin Leon, Clinton Warren, *-- Joey D. Carol, and myself. *-- This Yes/No dialog box should do the following: *-- A) Full 3-D effect(s) *-- B) Color options up to programmer/user *-- C) YES/NO buttons at bottom of dialog box *-- D) Allow for location on screen *-- E) Allow for up to 256 characters of text in message *-- F) Give a "windows" like title bar *-- G) Allow for screens bigger'n 25 lines ... (EGA43, *-- VGA50 ...) *-- Written for.: dBASE IV, 1.5 or later *-- Rev. History: 06/11/1993 -- Original *-- Calls.......: Shadow Procedure in PROC.PRG *-- Center Procedure in PROC.PRG *-- Bord3D Procedure in PROC.PRG *-- WordWrap Procedure in PROC.PRG *-- ColorBrk() Function in PROC.PRG *-- FBClrBrk() Function in PROC.PRG *-- Justify() Function in PROC.PRG *-- Called by...: Any *-- Usage.......: x=YesNo(<lDefault>,<cWhere>,<cTitle>,<cMessage>,; *-- <cColor>,<nStyle>) *-- Example.....: if YesNo(.t.,"CC","Delete Record?",; *-- "If you select [Yes] "+; *-- "you will delete this record.",cWind1,3) *-- Returns.....: logical *-- Parameters..: lDefault = Which menu pad do you wish to default to? *-- .T. = "Yes", .F. = "No" *-- cWhere = Where on the screen do you wish the dialog *-- box to appear? *-- UL = Upper Left *-- UC = Upper Center *-- UR = Upper Right *-- CL = Center Left *-- CC = Center Center (default) *-- CR = Center Right *-- BL = Bottom Left *-- BC = Bottom Center *-- BR = Bottom Right *-- cTitle = Title for the title bar, up to 30 chars *-- cMessage = Message, up to 254 characters *-- cColor = Colors in standard foreground/background. *-- If no colors given, you will get the *-- Borland "steel grey", with black text. *-- The buttons and title bar will end up *-- bright white on black. *-- nStyle = Border Style *-- 1 = Double Border, raised (default) *-- 2 = Double Border, recessed *-- 3 = Single Border, raised *-- 4 = Single Border, recessed *----------------------------------------------------------------------- parameters lDefault, cWhere, cTitle, cMessage, cColor, nStyle private nParm,nWidth,nHeight,cRow,cCol,nTop,nBottom,nLeft,nRight private cTempCol private nBordCol,nButtonRow,cWindow,cScreen,nScreen *-- save current screen, save current window m->cWindow = window() save screen to sYesNo *-- determine # of parameters passed, and set defaults if necessary nParm = pcount() if nParm < 6 && no selection for border-style, set to def. m->nStyle = 1 endif if m->nStyle < 1 .or. m->nStyle > 4 && don't screw with _my_ routine! m->nStyle = 1 endif if nParm < 5 && no colors, set to steel-grey m->cColor = "N/W,W+/N,N/W" endif if isblank(m->cColor) m->cColor = "N/W,W+/N,N/W" endif if isblank(cWhere) && default location is center of screen m->cWhere = "CC" endif *-- set some defaults m->nWidth = 36 + iif(m->nStyle < 3,4,2) && width of dialog box *-- determine height of window by text *-- if the remainder of the length of the message/width is > 0 *-- we have one more line of text, add 1, else add 0 *-- border will determine more ... (if it's 1 or 2, it's double-size, *-- so we add 4 lines (top/bottom * 2), if it's 3 or 4,it's single) *-- add 2 rows for the title, and 3 for the menu, and 1 for the *-- button borders ... m->nHeight = int(len(m->cMessage)/m->nWidth) + ; iif(mod(len(m->cMessage),m->nWidth) > 0,1,0) +; iif(m->nStyle < 3,3,1) +; 6 *-- now to determine window Coordinates m->cRow = left(m->cWhere,1) m->cCol = right(m->cWhere,1) *-- get screen height m->cScreen = SET("DISPLAY") if m->cScreen = "MONO" m->nScreen = 24 else m->nScreen = val(right(m->cScreen,2)) - 1 && (EGA25 = 0 to 24) endif *-- this is where we _really_ determine the coordinates do case && first let's get the rows (top/bottom) case m->cRow = "U" m->nTop = 1 case m->cRow ="B" m->nTop = (m->nScreen - m->nHeight - 2) &&leave room for shadow otherwise && "C" or center ... m->nTop = (m->nScreen - m->nHeight) / 2 endcase m->nBottom = m->nTop + m->nHeight do case && now for the columns case m->cCol = "L" m->nLeft = 5 case m->cCol = "R" m->nLeft = 35 otherwise && "C" or center m->nLeft = 20 endcase m->nRight = m->nLeft + m->nWidth *-- define window activate screen define window wYesNo from m->nTop,m->nLeft to m->nBottom,m->nRight; NONE color &cColor. *-- define menu define menu mYesNo m->nButtonRow = m->nHeight - iif(m->nStyle<3,3,2) define pad pYes of mYesNo prompt "[Yes]" at m->nButtonRow,10 define pad pNo of mYesNo prompt "[No]" at m->nButtonRow,25 on selection pad pYes of mYesNo deactivate menu on selection pad pNo of mYesNo deactivate menu *-- activate window do shadow with m->nTop,m->nLeft,m->nBottom,m->nRight activate window wYesNo *-- draw border m->cBordCol = left(m->cColor,at(",",m->cColor)-1) do bord3d with 0,0,m->nHeight,m->nWidth,m->cBordCol,m->nStyle *-- display title if len(m->cTitle) < m->nWidth m->cTitle = justify(m->cTitle,35,"C") if len(m->cTitle) < 35 m->cTitle = m->cTitle + " " endif endif m->cTempCol = colorbrk(m->cColor,2) m->cColorF = FBClrBrk("B",m->cTempCol) m->cColorB = FBClrBrk("B",colorbrk(m->cColor,1)) m->cColorAll= m->cColorF+"/"+m->cColorB m->nRow = iif(m->nStyle < 3,2,1) m->nCol = iif(m->nStyle < 3,3,2) @m->nRow, m->nCol say m->cTitle color &cTempCol. @m->nRow+1,m->nCol say replicate(chr(223),35) color &cColorAll. *-- display text do WordWrap with iif(m->nStyle<3,4,3),iif(m->nStyle<3,4,3),; m->cMessage,34 *-- set Y/N keys for menu pad clear typeahead && just to be safe on key label Y keyboard iif(pad() = "PYES","",chr(19))+chr(13) on key label N keyboard iif(pad() = "PNO" ,"",chr(4) )+chr(13) *-- deal with borders around the pads ... do bord3d with m->nButtonRow-1, 9,m->nButtonRow+1,15,m->cBordCol,3 do bord3d with m->nButtonRow-1,24,m->nButtonRow+1,29,m->cBordCol,3 *-- activate menu if lDefault activate menu mYesNo pad pYes else activate menu mYesNo pad pNo endif *-- cleanup on key label Y on key label N release window wYesNo restore screen from sYesNo release screen sYesNo release menu mYesNo if .not. isblank(m->cWindow) activate window &cWindow. endif RETURN iif(pad() = "PYES",.T.,.F.) *-- EoF: YesNo() PROCEDURE Bord3D *----------------------------------------------------------------------- *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030) *-- Date........: 06/02/1993 *-- Notes.......: This is an attempt to combine the 3-D border routines *-- (BORD3D through BORD3D4) -- allowing a selection *-- between four border styles ... *-- Written for.: dBASE IV, 1.5 or later *-- Rev. History: 06/02/1993 *-- Calls.......: BackColor() Function in PROC.PRG *-- Called by...: Any *-- Usage.......: do Bord3D with <nULR>,<nULC>,<nBRR>,<nBRC>,<cColor>,; *-- <nStyle> *-- Example.....: do Bord3D with 0,0,15,60,2 *-- Returns.....: None *-- Parameters..: nULR = Upper Left Row (Starting Coordinates) *-- nULC = Upper Left Column *-- nBRR = Bottom Right Row (Ending Coordinates) *-- nBRC = Bottom Right Column *-- cColor = Colors of Window/Box ... *-- nStyle = Border style: *-- 1 = Double, Raised *-- 2 = Double, Recessed *-- 3 = Single, Raised *-- 4 = Single, Recessed *----------------------------------------------------------------------- parameters nULR, nULC, nBRR, nBRC, cColor, nStyle private cBorder,cBackColor,cHighColor,cShadColor *-- deal with border ... m->cBorder = set("BORDER") set border to single *-- figure out colors m->cBackColor = backcolor(m->cColor) m->cHighColor = "W+/"+m->cBackColor m->cShadColor = "N/"+m->cBackColor if m->nStyle < 1 .or. m->nStyle > 4 && if not 1 through 4 ... m->nStyle = 1 endif do case case m->nStyle = 1 *-- Raised DOUBLE Border *-- Outside of "border" @m->nULR,m->nULC to m->nULR,m->nBRC color &cHighColor. @m->nULR,m->nULC to m->nBRR,m->nULC color &cHighColor. @m->nULR,m->nULC say chr(218) color &cHighColor. @m->nBRR,m->nULC say chr(192) color &cHighColor. @m->nULR,m->nBRC to m->nBRR,m->nBRC color &cShadColor. @m->nBRR,m->nULC+1 to m->nBRR,m->nBRC color &cShadColor. @m->nULR,m->nBRC say chr(191) color &cShadColor. @m->nBRR,m->nBRC say chr(217) color &cShadColor. *-- inside of "border" @m->nULR+1,m->nULC+2 to m->nULR+1,m->nBRC-2 color &cShadColor. @m->nULR+1,m->nULC+2 to m->nBRR-1,m->nULC+2 color &cShadColor. @m->nULR+1,m->nULC+2 say chr(218) color &cShadColor. @m->nBRR-1,m->nULC+2 say chr(192) color &cShadColor. @m->nULR+1,m->nBRC-2 to m->nBRR-1,m->nBRC-2 color &cHighColor. @m->nBRR-1,m->nULC+3 to m->nBRR-1,m->nBRC-2 color &cHighColor. @m->nULR+1,m->nBRC-2 say chr(191) color &cHighColor. @m->nBRR-1,m->nBRC-2 say chr(217) color &cHighColor. case m->nStyle = 2 *-- Recessed DOUBLE Border *-- Outside of "border" @m->nULR,m->nULC to m->nULR,m->nBRC color &cShadColor. @m->nULR,m->nULC to m->nBRR,m->nULC color &cShadColor. @m->nULR,m->nULC say chr(218) color &cShadColor. @m->nBRR,m->nULC say chr(192) color &cShadColor. @m->nULR,m->nBRC to m->nBRR,m->nBRC color &cHighColor. @m->nBRR,m->nULC+1 to m->nBRR,m->nBRC color &cHighColor. @m->nULR,m->nBRC say chr(191) color &cHighColor. @m->nBRR,m->nBRC say chr(217) color &cHighColor. *-- inside of "border" @m->nULR+1,m->nULC+2 to m->nULR+1,m->nBRC-2 color &cHighColor. @m->nULR+1,m->nULC+2 to m->nBRR-1,m->nULC+2 color &cHighColor. @m->nULR+1,m->nULC+2 say chr(218) color &cHighColor. @m->nBRR-1,m->nULC+2 say chr(192) color &cHighColor. @m->nULR+1,m->nBRC-2 to m->nBRR-1,m->nBRC-2 color &cShadColor. @m->nBRR-1,m->nULC+3 to m->nBRR-1,m->nBRC-2 color &cShadColor. @m->nULR+1,m->nBRC-2 say chr(191) color &cShadColor. @m->nBRR-1,m->nBRC-2 say chr(217) color &cShadColor. case m->nStyle = 3 *-- Raised SINGLE Border @m->nULR,m->nULC to m->nULR,m->nBRC color &cHighColor. @m->nULR,m->nULC to m->nBRR,m->nULC color &cHighColor. @m->nULR,m->nBRC to m->nBRR,m->nBRC color &cShadColor. @m->nBRR,m->nULC to m->nBRR,m->nBRC color &cShadColor. @m->nULR,m->nULC say chr(218) color &cHighColor. @m->nBRR,m->nULC say chr(192) color &cHighColor. @m->nULR,m->nBRC say chr(191) color &cShadColor. @m->nBRR,m->nBRC say chr(217) color &cShadColor. case m->nStyle = 4 *-- Recessed SINGLE Border @m->nULR,m->nULC to m->nULR,m->nBRC color &cShadColor. @m->nULR,m->nULC to m->nBRR,m->nULC color &cShadColor. @m->nULR,m->nBRC to m->nBRR,m->nBRC color &cHighColor. @m->nBRR,m->nULC to m->nBRR,m->nBRC color &cHighColor. @m->nULR,m->nULC say chr(218) color &cShadColor. @m->nBRR,m->nULC say chr(192) color &cShadColor. @m->nULR,m->nBRC say chr(191) color &cHighColor. @m->nBRR,m->nBRC say chr(217) color &cHighColor. endcase *-- reset border set border to &cBorder. RETURN *-- EoP: Bord3D FUNCTION YNC *----------------------------------------------------------------------- *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030) *-- Date........: 06/24/1993 *-- Notes.......: This is a variation of YESNO(), designed to allow the *-- programmer to give the user three buttons, instead of *-- two -- "Yes", "No" and "Cancel". The one MAJOR *-- difference is the logical parameter "lDefault" must *-- be changed to character, and the returned value will *-- also be character. The work involved is based on work *-- by Miriam Liskin, Martin Leon, Clinton Warren, *-- Joey D. Carol, and myself. *-- This Yes/No dialog box should do the following: *-- A) Full 3-D effect(s) *-- B) Color options up to programmer/user *-- C) YES/NO buttons at bottom of dialog box *-- D) Allow for location on screen *-- E) Allow for up to 256 characters of text in message *-- F) Give a "windows" like title bar *-- G) Allow for screens bigger'n 25 lines ... (EGA43, *-- VGA50 ...) *-- Written for.: dBASE IV, 1.5 or later *-- Rev. History: 06/24/1993 -- Original *-- Calls.......: Shadow Procedure in PROC.PRG *-- Center Procedure in PROC.PRG *-- Bord3D Procedure in PROC.PRG *-- WordWrap Procedure in PROC.PRG *-- ColorBrk() Function in PROC.PRG *-- FBClrBrk() Function in PROC.PRG *-- Justify() Function in PROC.PRG *-- Called by...: Any *-- Usage.......: x=YNC(<cDefault>,<cWhere>,<cTitle>,<cMessage>,; *-- <cColor>,<nStyle>) *-- Example.....: x= YNC("Y","CC","Delete Record?",; *-- "If you select [Yes] "+; *-- "you will delete this record.",cWind1,3) *-- do case *-- case x = "Y" *-- * do "Yes" action *-- case x = "N: *-- * do "No" action *-- otherwise *-- *-- do "Cancel" action *-- endcase *-- Returns.....: Character (first char of button) *-- Parameters..: cDefault = Which menu pad do you wish to default to? *-- "Y" = "Yes", "N" = "No", "C" = "Cancel" *-- cWhere = Where on the screen do you wish the dialog *-- box to appear? *-- UL = Upper Left *-- UC = Upper Center *-- UR = Upper Right *-- CL = Center Left *-- CC = Center Center (default) *-- CR = Center Right *-- BL = Bottom Left *-- BC = Bottom Center *-- BR = Bottom Right *-- cTitle = Title for the title bar, up to 30 chars *-- cMessage = Message, up to 254 characters *-- cColor = Colors in standard foreground/background *-- If no colors given, you will get the *-- Borland "steel grey", with black text. *-- The buttons and title bar will end up *-- bright white on black. *-- nStyle = Border Style *-- 1 = Double Border, raised (default) *-- 2 = Double Border, recessed *-- 3 = Single Border, raised *-- 4 = Single Border, recessed *----------------------------------------------------------------------- parameters cDefault, cWhere, cTitle, cMessage, cColor, nStyle private nParm,nWidth,nHeight,cRow,cCol,nTop,nBottom,nLeft,nRight,; cTempCol private nBordCol,nButtonRow,cWindow,cScreen,nScreen *-- save current screen, save current window m->cWindow = window() save screen to sYesNo *-- determine # of parameters passed, and set defaults if necessary m->nParm = pcount() if m->nParm < 6 && no selection for border-style, set to def. m->nStyle = 1 endif if m->nStyle < 1 .or. m->nStyle > 4 && don't screw with _my_ routine! m->nStyle = 1 endif if m->nParm < 5 && no colors, set to steel-grey m->cColor = "N/W,W+/N,N/W" endif if isblank(m->cColor) m->cColor = "N/W,W+/N,N/W" endif if isblank(m->cWhere) && default location is center of screen m->cWhere = "CC" endif *-- set some defaults m->nWidth = 36 + iif(m->nStyle < 3,4,2) && width of dialog box *-- determine height of window by text *-- if the remainder of the length of the message/width is > 0 *-- we have one more line of text, add 1, else add 0 *-- border will determine more ... (if it's 1 or 2, it's double-size, *-- so we add 4 lines (top/bottom * 2), if it's 3 or 4, it's *-- single ...) *-- add 2 rows for the title, and 3 for the menu, and 1 for the *-- button borders ... m->nHeight = int(len(m->cMessage)/m->nWidth) + ; iif(mod(len(m->cMessage),m->nWidth) > 0,1,0) +; iif(m->nStyle < 3,3,1) +; 6 *-- now to determine window Coordinates m->cRow = left(m->cWhere,1) m->cCol = right(m->cWhere,1) *-- get screen height m->cScreen = SET("DISPLAY") if m->cScreen = "MONO" m->nScreen = 24 else m->nScreen = val(right(m->cScreen,2)) - 1 && (EGA25 = 0 to 24) endif *-- this is where we _really_ determine the coordinates do case && first let's get the rows (top/bottom) case m->cRow = "U" m->nTop = 1 case m->cRow ="B" m->nTop = (m->nScreen - m->nHeight - 2) &&leave room for shadow otherwise && "C" or center ... m->nTop = (m->nScreen - m->nHeight) / 2 endcase m->nBottom = m->nTop + m->nHeight do case && now for the columns case m->cCol = "L" m->nLeft = 5 case m->cCol = "R" m->nLeft = 35 otherwise && "C" or center m->nLeft = 20 endcase m->nRight = m->nLeft + m->nWidth *-- define window activate screen define window wYesNo from m->nTop,m->nLeft to m->nBottom,m->nRight; NONE color &cColor. *-- define menu define menu mYesNo m->nButtonRow = m->nHeight - iif(m->nStyle<3,3,2) m->nYes = 5 && column for "[Yes]" button m->nNo = (m->nWidth-6)/2 && column for "[No]" button -- center it m->nCan = (m->nWidth-13) && column for "[Cancel]" button define pad pYes of mYesNo prompt "[Yes]" at m->nButtonRow,m->nYes define pad pNo of mYesNo prompt "[No]" at m->nButtonRow,m->nNo define pad pCan of mYesNo prompt "[Cancel]" at m->nButtonRow,m->nCan on selection pad pYes of mYesNo deactivate menu on selection pad pNo of mYesNo deactivate menu on selection pad pCan of mYesNo deactivate menu *-- activate window do shadow with m->nTop,m->nLeft,m->nBottom,m->nRight activate window wYesNo *-- draw border m->cBordCol = left(m->cColor,at(",",m->cColor)-1) do bord3d with 0,0,m->nHeight,m->nWidth,m->cBordCol,m->nStyle *-- display title if len(m->cTitle) < m->nWidth m->cTitle = justify(m->cTitle,35,"C") if len(m->cTitle) < 35 m->cTitle = m->cTitle + " " endif endif m->cTempCol = colorbrk(m->cColor,2) m->cColorF = FBClrBrk("B",m->cTempCol) m->cColorB = FBClrBrk("B",colorbrk(m->cColor,1)) m->cColorAll= m->cColorF+"/"+m->cColorB m->nRow = iif(m->nStyle < 3,2,1) nCol = iif(m->nStyle < 3,3,2) @m->nRow, m->nCol say m->cTitle color &cTempCol. @m->nRow+1,m->nCol say replicate(chr(223),35) color &cColorAll. *-- display text do WordWrap with iif(m->nStyle<3,4,3),iif(m->nStyle<3,4,3),; m->cMessage,34 *-- set Y/N keys for menu pad clear typeahead && just to be safe *-- if we're ON the pad user selected, do nothing, else go left or *-- right as needed, and then issue a "Return" (chr(13)) on key label Y keyboard iif(pad() = "PYES","",; iif(pad()="PNO",chr(19),chr(4) ) )+chr(13) on key label N keyboard iif(pad() = "PNO" ,"",; iif(pad()="PYES",chr(4),chr(19) ) )+chr(13) on key label C keyboard iif(pad() = "PCAN","",; iif(pad()="PNO",chr(4),chr(19) ) )+chr(13) *-- deal with borders around the pads ... do bord3d with m->nButtonRow-1,m->nYes-1,m->nButtonRow+1,; m->nYes+5,m->cBordCol,3 do bord3d with m->nButtonRow-1,m->nNo-1, m->nButtonRow+1,; m->nNo+4, m->cBordCol,3 do bord3d with m->nButtonRow-1,m->nCan-1,m->nButtonRow+1,; m->nCan+8,m->cBordCol,3 *-- activate menu do case case upper(m->cDefault) = "Y" activate menu mYesNo pad pYes case upper(m->cDefault) = "N" activate menu mYesNo pad pNo case (m->cDefault) = "C" activate menu mYesNo pad pCan otherwise && default to 'Yes' activate menu mYesNo pad pYes endcase *-- cleanup on key label Y on key label N on key label C release window wYesNo restore screen from sYesNo release screen sYesNo release menu mYesNo if .not. isblank(m->cWindow) activate window &cWindow. endif RETURN substr(pad(),2,1) *-- EoF: YNC() *======================================================================= * COLOR PROCESSING -- These routines handle setting colors, dealing with * checking how colors are set, and so on. Anything that's not here is in * the library file: COLOR.PRG. *======================================================================= PROCEDURE SetColor *----------------------------------------------------------------------- *-- Programmer..: Ken Mayer (CIS: 71333,1030) *-- Date........: 07/24/1992 *-- Notes.......: This routine is designed set colors of the primary *-- "areas" on the screen, based on a color memvar being *-- passed to it. This color memvar should contain two *-- sets of colors (normal and enhanced). See below for *-- more details. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 07/24/1992 -- Original *-- Calls.......: ColorBrk() Function in PROC.PRG *-- Called by...: Any *-- Usage.......: do SetColor with <cColorVar> *-- Example.....: cOldColor = set("ATTRIBUTES") && save old colors *-- do SetColor with cl_dialog *-- *-- do whatever needs to be done with these colors *-- do ReColor with cOldColor && restore old colors *-- Returns.....: None *-- Parameters..: cColorVar = Color memvar. This must contain a "normal" *-- color and a "highlight" color in the *-- format: *-- <forg>/<back>,<forg>/<back> *-- i.e., "rg+/gb,w+/b" *----------------------------------------------------------------------- parameters cColorVar private cNormCol,cHighCol m->cNormCol = colorbrk(m->cColorVar,1) && extract "normal" colors m->cHighCol = colorbrk(m->cColorVar,2) && extract "highlight" colors set color of normal to &cNormCol. && regular screen/text colors set color of messages to &cNormCol. && messages/menu pads, etc. set color of box to &cHighCol. && borders set color of fields to &cHighCol. && data entry fields set color of highlight to &cHighCol. && highlighted items in menus RETURN *-- EoP: SetColor PROCEDURE ReColor *----------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 72662,1302) *-- Date........: 04/23/1992 *-- Notes.......: Restores colors to those held in a string of the form *-- returned by set("ATTRIBUTE"). *-- Written for.: dBASE IV, Versions 1.0 - 1.5. *-- Rev. History: 04/23/1992 -- Original *-- Calls : None *-- Called by...: Any *-- Usage.......: DO ReColor WITH <cColors> *-- Example.....: DO Recolor WITH OldColors *-- Parameters..: cColors, a string in the form returned by *-- set("ATTRIBUTE"). *-- Side effects: Changes the screen colors. *----------------------------------------------------------------------- parameters cColors private cThis, cNext, nAt, cLeft, nX, cAreas m->cAreas = " NORMHIGHBORDMESSTITLBOX INFOFIEL" m->cLeft = m->cColors + ", " m->nX = 0 do while m->nX < 8 m->nX = m->nX + 1 m->cThis = substr( m->cAreas, 4 * m->nX, 4 ) if m->nX = 3 m->nAt = at( "&", m->cLeft ) m->cNext = left( m->cLeft, m->nAt - 2 ) m->cLeft = substr( m->cLeft, m->nAt + 3 ) SET COLOR TO , , &cNext. else m->nAt = at( ",", m->cLeft ) m->cNext = left( m->cLeft, m->nAt - 1 ) m->cLeft = substr( m->cLeft, m->nAt + 1 ) SET COLOR OF &cThis. TO &cNext. endif enddo RETURN *-- EoP: ReColor FUNCTION ColorBrk *----------------------------------------------------------------------- *-- Programmer..: Ken Mayer (CIS: 71333,1030) *-- Date........: 03/24/1993 *-- Notes.......: This routine is designed to be used with any of my *-- functions and procedures that accept a memory variable *-- for color, and use a window. It's purpose is to break *-- that color var into it's components (depending on *-- which one the user wants) and return those components, *-- so that they can then be used in SET COLOR OF ... *-- commands. *-- Written for.: dBASE IV, 1.1, 1.5 (written because of 1.5, but will *-- work in 1.1) *-- Rev. History: 07/22/1992 - modified to handle memvars/color strings *-- that may have only two parts to them (no *-- <border>...), so that if the <nField> parm is 2, we *-- get a valid value. *-- 03/24/1993 -- Lee Hite - Fixed to work correctly when *-- <cColorVar> contains a single colorset (i.e., "b/w"). *-- Calls.......: None *-- Called by...: Any *-- Usage.......: ColorBrk(<cColorVar>,<nField>) *-- Example.....: set color of normal to ColorBrk(cColor,1) *-- Returns.....: Either the field you asked for (1 thru 3) or null *-- string (""). *-- Parameters..: cColorVar = Color variable to extract data from *-- Assumes the form: *-- <main color>,<highlight>,<border> *-- Where each part uses: <foreground>/<background> *-- format: i.e., rg+/gb,w+/b,rg+/gb *-- nField = Field you want to extract *----------------------------------------------------------------------- parameters cColorVar, nField private cReturn, cExtracted do case case m->nField = 1 if at(",",m->cColorVar) > 0 m->cReturn = left(m->cColorVar,at(",",m->cColorVar)-1) else m->cReturn = m->cColorVar endif case m->nField = 2 m->cExtract = substr(m->cColorVar,at(",",m->cColorVar)+1) && everything to the right of comma if at(",",m->cExtract) > 0 m->cReturn = left(m->cExtract,at(",",m->cExtract)-1) && left of second comma else m->cReturn = m->cExtract endif case m->nField = 3 m->cExtract = substr(m->cColorVar,at(",",m->cColorVar)+1) if at(",",m->cExtract) > 0 m->cReturn = substr(m->cExtract,at(",",m->cExtract)+1) else m->cReturn = "" endif otherwise m->cReturn = "" endcase RETURN m->cReturn *-- EoF: ColorBrk() FUNCTION FBClrBrk *----------------------------------------------------------------------- *-- Programmer..: Joey D. Carroll (JOEY on USSBBS) *-- Date........: 11/12/1992 *-- Notes.......: Extracts foreground/background colors from a string in *-- the form of a literal "n/gb" or of a variable. It is *-- useful to use COLORBRK() to obtain this value. *-- Written for.: dBASE IV, ver 1.5 *-- Rev. History: 11/12/1992 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: ?? FBClrBrk("B","w+/gr") *-- Example.....: cNormalClr = "w+/gr" *-- cForeClr = FBClrBrk("F",cNormalClr) && = "w+" *-- cBackClr = FBClrBrk("B",cNormalClr) && = "gr" *-- Returns.....: a sub-string of cColor *-- Parameters..: cType = "F" for foreground color "B" for Background *-- cColor = the color you want to extract from *----------------------------------------------------------------------- parameters cType,cColor private cRetClr if upper(m->cType) = "F" m->cRetClr = iif(at("/",m->cColor) = 0,m->cColor,left(m->cColor,; at("/",m->cColor)-1)) else && = "B" m->cRetClr = substr(m->cColor,at("/",m->cColor) + 1,2) endif RETURN m->cRetClr *-- EoF: FBClrBrk() FUNCTION BackColor *----------------------------------------------------------------------- *-- Programmer..: Jay Parsons (CIS: 72662,1302) *-- Date........: 02/24/1993 *-- Notes : Returns background part of color string. *-- Written for.: dBASE IV, Version 1.5. *-- Rev. History: 02/04/1993 -- Original Release *-- Calls : None *-- Called by...: Any *-- Usage.......: BackColor( <cColor> ) *-- Example.....: ? BackColor( "N/BG" ) *-- Parameters..: cColor - String holding color foreground and *-- background *-- Returns.....: Character, string with background portion of the *-- color. Returns empty string if no such portion. *----------------------------------------------------------------------- parameters cColor private m->cRet m->cRet = upper( trim( ltrim( m->cColor ) ) ) if "/" $ m->cRet m->cRet = substr( m->cRet, at( "/", m->cRet ) + 1 ) if "*" $ m->cRet m->cRet = stuff( m->cRet, at( "*", m->cRet ), 1, "" ) endif if "+" $ m->cRet m->cRet = stuff( m->cRet, at( "+", m->cRet ), 1, "" ) endif else m->cRet = "" endif RETURN upper( ltrim( trim( m->cRet ) ) ) *-- EoF: BackColor() *======================================================================= * STRING Manipulation. Most of these are in the library file: * STRINGS.PRG. The ones here are common to a lot of apps and functions, * and are here so that the library STRINGS.PRG need not be called. *======================================================================= FUNCTION AllTrim *----------------------------------------------------------------------- *-- Programmer..: Phil Steele (from PCSDEMO.PRG -- Public Domain) *-- Date........: 05/23/1991 *-- Notes.......: Complete trims edges of field (left and right) *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 05/23/1991 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: alltrim(<cString>) *-- Example.....: ? alltrim(" Test String ") *-- Returns.....: Trimmed string, i.e.:"Test String" *-- Parameters..: cString = string to be trimmed *----------------------------------------------------------------------- parameters cString RETURN ltrim(rtrim(m->cString)) *-- EoF: AllTrim() FUNCTION Justify *----------------------------------------------------------------------- *-- Programmer..: Roland Bouchereau (Ashton-Tate/Borland) *-- Date........: 03/24/1993 *-- Notes.......: Used to pad a field/string on the right, left or both, *-- justifying or centering it within the length *-- specified. If the length of the string passed is *-- greater than the size needed, the function will *-- truncate it. Taken from Technotes, June 1990. Defaults *-- to Left Justify if invalid TYPE is passed ... *-- Written for.: dBASE IV, 1.0 *-- Rev. History: Original function 06/15/1991 *-- 12/17/1991 -- Modified into ONE function from three by *-- Ken Mayer, added a third parameter to handle that. *-- 12/23/1992 -- Modified by Joey Carroll to use STUFF() *-- instead of TRANSFORM(). *-- 03/24/1993 -- Modified by Lee Hite, as the center *-- option wasn't working quite right ... *-- Calls.......: None *-- Called by...: Any *-- Usage.......: Justify(<cFld>,<nLength>,"<cType>") *-- Example.....: ?? Justify(Address,25,"R") *-- Returns.....: Padded/truncated field *-- Parameters..: cFld = Field/Memvar/Character String to justify *-- nLength = Width to justify within *-- cType = Type of justification: L=Left, C=Center, *-- R=Right *----------------------------------------------------------------------- parameters cFld,nLength,cType private cReturn m->cType = upper(m->cType) && just making sure ... if type("m->cFld")+type("m->nLength")+type("m->cType") $ "CNC,CFC" *-- set a picture function of 'X's, with @I,@J or @B function m->cReturn = space(m->nLength) m->cReturn = stuff(m->cReturn,; iif(m->cType = "C",((m->nLength-len(m->cFld))/2)+1,; iif(m->cType = "R",m->nLength-len(m->cFld)+1,1)),; len(m->cFld),m->cFld) else m->cReturn = "" endif RETURN m->cReturn *-- EoF: Justify() FUNCTION State *----------------------------------------------------------------------- *-- Programmer..: David G. Franknbach (CIS: 72147,263) *-- Date........: 04/22/1992 *-- Notes.......: Validation of state codes -- used to ensure that a *-- user doing data entry will enter the proper codes. *-- Added a few US Territory codes as well (Puerto Rico, *-- etc.) *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 12/02/1991 *-- 03/11/1992 -- Modified by Ken Mayer to handle *-- the extra US Territories, and to ensure that the data *-- is at least temporarily in upper case when doing the *-- check ... *-- 04/22/1992 -- Modified by Jay Parsons to shorten *-- (simplify) the routine by removing the cSTATE2 memvar. *-- Calls.......: None *-- Called by...: None *-- Usage.......: STATE(<cState>) *-- Example.....: @5,10 get cState valid required state(cState); *-- error chr(7)+"This is not a valid state code!" *-- Returns.....: Logical (.t. if found, .f. otherwise) *-- Parameters..: cState = state code to be checked .... *----------------------------------------------------------------------- parameters cState m->cStateList = "AL|AK|AZ|AR|CA|CO|CT|DE|DC|FL|GA|HI|ID|IL|IN|IA|"+; "KS|KY|LA|ME|MD|MA|MI|MN|MS|MO|MT|NE|NV|NH|NJ|NM|NY|NC|ND|"+; "OH|OK|OR|PA|RI|SC|SD|TN|TX|UT|VT|VA|WA|WV|WI|WY|PR|AS|GU|"+; "CM|TT|VI|" m->lOK = upper(m->cState) $ m->cStateList RETURN m->lOK *-- EoF: State() PROCEDURE WordWrap *----------------------------------------------------------------------- *-- Programmer..: David Frankenbach (CIS: 72147,2635) *-- Date........: 01/14/1993 (Version 1.1) *-- Notes.......: Wraps a long string, breaking it into strings that *-- have a maximum length of nWidth. The first output is *-- displayed @nRow, nCol. Words are not split ... *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 01/06/1993 -- Original Release (Version 1.0) *-- 01/14/1993 -- Version 1.1 -- Corrected side-effect of *-- destroying string arg, added test for *-- string[nWidth+1] = " " *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do WordWrap with <nRow>, <nCol>, <cString>, <nWidth> *-- Example.....: do WordWrap with 2,2,cText,38 *-- Returns.....: None *-- Parameters..: nRow = Row to display first line at *-- nCol = Left side of area to display text at *-- cString = text to wrap *-- nWidth = Width of area to wrap text in *----------------------------------------------------------------------- parameters nRow, nCol, cString, nWidth private cTemp, nI, cStr m->cStr = m->cString && work with a COPY of input, to avoid && destroying original do while len(m->cStr) > 0 && while there's something to work on if (m->nWidth < len(m->cStr)) m->nI = m->nWidth && look for last " " in first nWidth if substr(m->cStr,m->nI+1,1) # " " do while ( (m->nI > 0) .and. (substr(m->cStr,m->nI,1)# " ")) m->nI = m->nI - 1 enddo endif if m->nI = 0 && no spaces m->nI = m->nWidth && get first nWidth characters endif else m->nI = len(m->cStr) && use the rest of the string endif m->cTemp = left(m->cStr,m->nI) && get the part we're going to && display if m->nI < len(m->cStr) && remove that part m->cStr = ltrim(substr(m->cStr,m->nI + 1)) else m->cStr = "" endif *-- display it @m->nRow,m->nCol say m->cTemp *-- move to next row m->nRow = m->nRow + 1 enddo RETURN *-- EoP: WordWrap *======================================================================= * DATE HANDLING ROUTINES -- Most of these are now in the library file: * DATES.PRG (included with this version of PROC). However, a few are * below, as they have become 'standard' routines in many of my systems. *======================================================================= FUNCTION DateText *----------------------------------------------------------------------- *-- Programmer..: Miriam Liskin *-- Date........: 05/23/1991 *-- Notes.......: Display date in format Month, day year (e.g., *-- July 1, 1991) *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 05/23/1991 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: DateText(<dDate>) *-- Example.....: ? datetext(date()) *-- Returns.....: July 1, 1991 *-- Parameters..: dDate = date to be converted *----------------------------------------------------------------------- parameters dDate RETURN CMONTH(m->dDate)+" "+ltrim(str(day(m->dDate),2))+", "+; str(year(m->dDate),4) *-- EoF: DateText() FUNCTION DateText2 *----------------------------------------------------------------------- *-- Programmer..: Miriam Liskin *-- Date........: 05/23/1991 *-- Notes.......: Display date in format day-of-week, Month day, year *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 05/23/1991 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: DateText2(<dDate>) *-- Example.....: ? DateText2(date()) *-- Returns.....: Thursday, July 1, 1991 *-- Parameters..: dDate = date to be converted *----------------------------------------------------------------------- parameters dDate RETURN CDOW(m->dDate)+", "+cmonth(m->dDate)+" "+; ltrim(str(day(m->dDate),2))+", "+str(year(m->dDate),4) *-- EoF: DateText2() FUNCTION Age *----------------------------------------------------------------------- *-- Programmer..: Martin Leon (HMAN) *-- Date........: 10/23/1991 *-- Notes.......: Returns age of person, given their birthdate as of *-- DATE(), effectively, as of "Today". *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 10/23/1991 -- Original *-- 08/10/1993 -- Went and "stole" code from the *-- routine AGE2() in DATES.PRG, Zak and Jay Parsons ... *-- It's more efficient. *-- Calls.......: None *-- Called by...: Any *-- Usage.......: Age(<dBDay>) *-- Example.....: ? "Joe is "+ltrim(str(age(dBDay)))+" today ..." *-- Returns.....: Numeric value in years *-- Parameters..: dBDay = birthdate of person attempting to find age of. *----------------------------------------------------------------------- parameters dBDay RETURN floor( ( val( dtos( date() ) ) - val( dtos( dBDay ) ) ) ; / 10000 ) *-- EoF: Age() *======================================================================= * MISC ROUTINES -- Ones that don't fit into other categories, quite ... * but are none-the-less very useful ... many of these routines have been * placed in the library file: MISC.PRG. *======================================================================= FUNCTION DosRun *----------------------------------------------------------------------- *-- Programmer..: Michael P. Dean (Ashton-Tate) *-- Date........: 05/01/1992 *-- Notes.......: A routine to run a DOS program, checks to see if a *-- window is active -- if so, it avoids the inevitable *-- "Press any key to continue" and the subsequent messing *-- up of the screen display. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: Pulled from A-T BBS *-- 05/13/1991 - modified by Ken Mayer to use the DBASE *-- RUN() function, rather than the ! or RUN commands. *-- (suggested by Clinton L. Warren (VBCES).) *-- Minor additions for screens from "Bosephus" on ATBBS *-- 10/31/91 *-- 12/14/1991 - modified by Jim Magnant (TXAGGIE) to *-- deactivate and reactivate up to 10 windows ... *-- 04/21/1992 -- Modified for dBASE IV, 1.5 to use memory *-- handling parameters (.t.,<command>,.t.) of RUN() *-- function. *-- 05/01/1992 -- Modified to allow use with EITHER 1.1 or *-- 1.5. By calling VERSION() without a parm, the version *-- of dBASE or RUNTIME is the last three characters on *-- the right. Taking the VAL() of that, we can ask if *-- the version is => 1.5 and process from there. *-- Calls.......: None *-- Called by...: Any *-- Usage.......: DosRun(<cCmd>) *-- Example.....: ndummy = dosrun("DIR /W /P") *-- * or *-- ndummy = dosrun(memvar) && where memvar contains dos *-- && command and parameters ... *-- Returns.....: Nul *-- Parameters..: cCmd = Command (and parameters) to be executed *----------------------------------------------------------------------- parameter cCmd private aWindow, n, nRun save screen to sDOS && save screen ... m->n = 0 && set to 0 in case there are NO Windows active declare aWindow[10] aWindow[1] = window() && grab window name of current window if len(trim(aWindow[1])) > 0 && if there's a window, deactivate m->n = 1 do while len(trim(aWindow[m->n])) > 0 && if there are more windows deactivate window &aWindow.[n] && deactivate them, too m->n = m->n + 1 aWindow[m->n] = window() enddo endif set console off && don't display to screen if val(right(version(),3)) => 1.5 && check version number. If > 1.5 nRun = run(.t.,"&cCmd.",.t.) && use complete swapping of dBASE, && etc. else && else it's 1.1 or 1.0 nRun = run("&cCmd.") && use older version of RUN() && function endif set console on && ok, display to screen m->n = m->n - 1 && compensate for final n=n+1 if len(trim(aWindow[1])) > 1 && if there's a window, do while m->n > 0 && reactivate all but last activate window &aWindow.[m->n] && activate m->n = m->n - 1 && decrement stack enddo activate window &aWindow.[1] && activate final window ... endif restore screen from sDOS release screen sDOS RETURN "" *-- EoF: DosRun() FUNCTION ScrnRpt *----------------------------------------------------------------------- *-- Programmer..: Bryan Flynn (AT/BOR-BBS) *-- Date........: 10/31/1991 *-- Notes.......: Used to display a dBASE Report on screen, allowing *-- pauses when the screen is full. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: Changed by a lot of people to current version. *-- Calls.......: None *-- Called by...: Any *-- Usage.......: ?ScrnRpt("<cRpt cArg>") *-- Example.....: ?ScrnRpt("FT_REP1 FOR PROB='HPEQUIP'") *-- Returns.....: "" (Nul) *-- Parameters..: cRpt = Name of report with any arguments for command *-- line *----------------------------------------------------------------------- Parameter cRpt private lPWait, nPLength, cEscape *-- save system variables m->lPWait = _pwait m->nPLength = _plength m->cEscape = SET("ESCAPE") *-- set new variables _pwait = .t. _plength = iif("43" $ SET("DISPLAY"),40,25) && if EGA43, set to 40, else 25 set escape on *-- store current screen save screen to sTemp clear *-- set printer to nowhere and generate report set printer to nul report form &cRpt. noeject to print *-- set things back to normal set escape &cEscape. set printer to LPT1 wait clear restore screen from sTemp release screen sTemp _pwait = m->lPWait _plength = m->nPLength RETURN "" *-- EoF: ScrnRpt() PROCEDURE SetMouse *----------------------------------------------------------------------- *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030) *-- Date........: 03/11/1993 *-- Notes.......: Allows user to toggle mouse on/off. *-- Written for.: dBASE IV, 2.0 *-- Rev. History: 03/11/1993 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: Do SetMouse *-- Example.....: c_Mouse = "ON" *-- on key label alt-m do setmouse *-- Returns.....: None *-- Parameters..: c_Mouse = 'current' status of mouse -- this is a *-- public memvar, and should be defined as *-- such. This routine will change the status *-- of said memvar if it exists, or return if *-- it does not. *-- c_Mouse is not _really_ a parameter ... *----------------------------------------------------------------------- if type("m->c_Mouse") = "L" .or. type("m->c_Mouse") = "U" RETURN endif if upper(m->c_Mouse) = "ON" set mouse off m->c_Mouse = "OFF" else set mouse on m->c_Mouse = "ON" endif RETURN *-- EoP: SetMouse FUNCTION SwitchLib *----------------------------------------------------------------------- *-- Programmer..: Ken Mayer (CIS: 71333,1030) *-- Date........: 05/01/1992 *-- Notes.......: Used with dBASE IV, 1.5 to switch LIBRARY files. It's *-- designed as a quick toggle between libraries. See *-- example below. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 05/01/1992 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: SwitchLib(<cNewLib>) *-- Example.....: cOldLib = SwitchLib("FILES") *-- *-- execute function/procedure needed *-- cOldLib = SwitchLib("&cOldLib") *-- Returns.....: Old Library setting *-- Parameters..: cNewLib = Library file you wish to change to. If the *-- file extension is not '.PRG', you should add *-- the file extension to the description (I.e, *-- "FILES.LIB") *----------------------------------------------------------------------- parameters cNewLib private cCurLib m->cCurLib = set("LIBRARY") set library to &cNewLib. RETURN m->cCurLib *-- EoF: SwitchLib() FUNCTION VerLevel *----------------------------------------------------------------------- *-- Programmer..: Bowen Moursund (CIS: 72662,436) *-- Date........: 06/24/1992 *-- Notes.......: Returns the numeric version number of the current *-- version of dBASE or RUNTIME. Useful in version *-- specific routines. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: 06/24/1992 -- Original *-- Calls.......: None *-- Called by...: Any *-- Usage.......: VerLevel() *-- Example.....: if VerLevel() >= 1.5 *-- Returns.....: a numeric equivalent of Version() *-- Parameters..: None *----------------------------------------------------------------------- private cVersion, nPos m->cVersion = version() m->nPos = 1 do while left(right(m->cVersion,m->nPos),1) # " " m->nPos = m->nPos + 1 enddo RETURN val(right(m->cVersion,m->nPos+1)) *-- Eof() VerLevel *======================================================================= *-- End of Procedure File -- PROC.PRG *=======================================================================